home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / top / has-macros.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  1.4 KB  |  57 lines  |  [TEXT/CCL2]
  1. ;;; General macros for the Haskell compiler
  2.  
  3. (define-syntax (remember-context exp . body)
  4.   (let ((temp  (gensym)))
  5.     `(let ((,temp  ,exp))
  6.        (dynamic-let ((*context* (if (ast-node-line-number ,temp)
  7.                     ,temp 
  8.                     (dynamic *context*))))
  9.          ,@body))))
  10.  
  11. (define-syntax (maybe-remember-context exp . body)
  12.   (let ((temp  (gensym)))
  13.     `(let ((,temp  ,exp))
  14.        (if (ast-node-line-number ,temp)
  15.        (dynamic-let ((*context* ,temp)) ,@body)
  16.        (begin ,@body)))))
  17.  
  18. (define-syntax (recover-errors error-value . body)
  19.   (let ((local-handler (gensym)))
  20.     `(let/cc ,local-handler
  21.        (dynamic-let ((*recoverable-error-handler*
  22.                (lambda () (funcall ,local-handler ,error-value))))
  23.          ,@body))))
  24.  
  25. ;;; This is for iterating a list of contexts over a list of types.
  26.  
  27. (define-syntax (do-contexts cbinder tbinder . body)
  28.   (let ((cvar (car cbinder))
  29.     (cinit (cadr cbinder))
  30.     (tvar (car tbinder))
  31.     (tinit (cadr tbinder))
  32.     (cv (gensym))
  33.     (tv (gensym)))
  34.     `(do ((,cv ,cinit (cdr ,cv))
  35.       (,tv ,tinit (cdr ,tv)))
  36.      ((null? ,cv))
  37.        (let ((,tvar (car ,tv)))
  38.      (dolist (,cvar (car ,cv))
  39.        ,@body)))))
  40.  
  41. ;; dolist for 2 lists at once.
  42.  
  43. (define-syntax (dolist2 a1 a2 . body)
  44.   (let ((a1var (car a1))
  45.     (a1init (cadr a1))
  46.     (a2var (car a2))
  47.     (a2init (cadr a2))
  48.     (a1l (gensym))
  49.     (a2l (gensym)))
  50.     `(do ((,a1l ,a1init (cdr ,a1l))
  51.       (,a2l ,a2init (cdr ,a2l)))
  52.      ((null? ,a1l))
  53.        (let ((,a1var (car ,a1l))
  54.          (,a2var (car ,a2l)))
  55.      ,@body))))
  56.  
  57.